home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Libraries / PNL Libraries / MyBinHex.p < prev    next >
Encoding:
Text File  |  1995-10-23  |  11.7 KB  |  488 lines  |  [TEXT/CWIE]
  1. unit MyBinHex;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Files;
  7.  
  8.     const
  9.         notEnoughData = 1;
  10.  
  11.     type
  12.         BinHexEncodeState = record
  13.                 state: integer;
  14.                 bits: integer;
  15.                 repcnt, lastbyte: integer;
  16.                 linepos: integer;
  17.                 dlen, rlen: longint;
  18.                 crc: integer;
  19.                 crlf: boolean;
  20.                 datafork: boolean;
  21.             end;
  22.  
  23.     procedure StartupBinHex;
  24.     procedure BinHexEncodeStart (var bh: BinHexEncodeState; crlf: boolean; name: str63; var fi: FInfo; dlen, rlen: longint; p: ptr; len: longint; var count: longint);
  25.     procedure BinHexEncodeChunk (var bh: BinHexEncodeState; p: ptr; len: longint; var count: longint; eofork, eofile: boolean);
  26.     function BinHexDecodeStart (var bh: BinHexEncodeState; var name: str63; var fi: FInfo; var dlen, rlen: longint; p: ptr; len: longint; var count: longint): OSErr;
  27.     function BinHexDecodeChunk (var bh: BinHexEncodeState; inp: ptr; inlen: longint; var inused: longint; outp: ptr; outlen: longint; var outused: longint; var eofork, eofile: boolean): OSErr;
  28.  
  29. implementation
  30.  
  31.     uses
  32.         Memory, CalcCRC, QLowLevel, MyStartup;
  33.  
  34.     const
  35.         binhex_start_string = '(This file must be converted with BinHex 4.0)';
  36.         binhex_check_length = 33;
  37.         first_binhex_char = ord('(');
  38.         second_binhex_char = ord('T');
  39.         mapbc = '!"#$%&''()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr';
  40.         rep = $90;
  41.         dud_byte = $FF;
  42.  
  43.     var
  44.         map: packed array[0..255] of byte;
  45.  
  46.     procedure BinHexEncodeStart (var bh: BinHexEncodeState; crlf: boolean; name: str63; var fi: FInfo; dlen, rlen: longint; p: ptr; len: longint; var count: longint);
  47.         var
  48.             headerlen: integer;
  49.             q: ptr;
  50.             s: Str255;
  51.     begin
  52.         q := p;
  53.         s := binhex_start_string;
  54.         BlockMoveData(@s[1], q, length(s));
  55.         OffsetPtr(q, length(s));
  56.         q^ := 13;
  57.         OffsetPtr(q, 1);
  58.         if crlf then begin
  59.             q^ := 10;
  60.             OffsetPtr(q, 1);
  61.         end;
  62.         q^ := ord(':');
  63.         OffsetPtr(q, 1);
  64.         headerlen := SubPtrPtr(q, p);
  65.         p := q;
  66.         BlockMoveData(@name, q, length(name) + 1);
  67.         OffsetPtr(q, length(name) + 1);
  68.         q^ := 0;
  69.         OffsetPtr(q, 1);
  70.         BlockMoveData(@fi.fdType, q, 4);
  71.         OffsetPtr(q, 4);
  72.         BlockMoveData(@fi.fdCreator, q, 4);
  73.         OffsetPtr(q, 4);
  74.         BlockMoveData(@fi.fdFlags, q, 2);
  75.         OffsetPtr(q, 2);
  76.         BlockMoveData(@dlen, q, 4);
  77.         OffsetPtr(q, 4);
  78.         BlockMoveData(@rlen, q, 4);
  79.         OffsetPtr(q, 4);
  80.         count := SubPtrPtr(q, p);
  81.         bh.state := 0;
  82.         bh.bits := 0;
  83.         bh.linepos := 1;
  84.         bh.crc := 0;
  85.         bh.crlf := crlf;
  86.         BinHexEncodeChunk(bh, p, len - headerlen, count, true, false);
  87.         count := count + headerlen;
  88.     end;
  89.  
  90.     procedure BinHexEncodeChunk (var bh: BinHexEncodeState; p: ptr; len: longint; var count: longint; eofork, eofile: boolean);
  91. { p & len may be odd, count is in/out }
  92.         var
  93.             c, newcount: longint;
  94.             src, dst: ptr;
  95.             b1, b2, b3: integer;
  96.     begin
  97.         CalcMBCRCBlock(p, count, bh.crc);
  98.         if eofork then begin
  99.             BlockMoveData(@bh.crc, AddPtrLong(p, count), 2);
  100.             count := count + 2;
  101.             bh.crc := 0;
  102.         end;
  103.         if count > 0 then begin
  104.             dst := AddPtrLong(p, len);
  105.             src := AddPtrLong(p, count);
  106. { First RLE encode (ie, change $90 to $90,$00) }
  107.             newcount := 0;
  108.             for c := 1 to count do begin
  109.                 OffsetPtr(src, -1);
  110.                 if BAND(src^, $FF) = rep then begin
  111.                     OffsetPtr(dst, -1);
  112.                     dst^ := 0;
  113.                     newcount := newcount + 1;
  114.                 end;
  115.                 OffsetPtr(dst, -1);
  116.                 dst^ := src^;
  117.                 newcount := newcount + 1;
  118.             end;
  119. { Then enhqx }
  120.             src := dst;
  121.             dst := p;
  122.             count := 0;
  123.             while newcount > 0 do begin
  124.                 case bh.state of
  125.                     0:  begin
  126.                         while (newcount >= 3) & (bh.linepos < 60) do begin
  127.                             b1 := src^;
  128.                             OffsetPtr(src, 1);
  129.                             b2 := src^;
  130.                             OffsetPtr(src, 1);
  131.                             b3 := src^;
  132.                             OffsetPtr(src, 1);
  133.                             dst^ := signedByte(mapbc[BAND(BSR(b1, 2), $3F) + 1]);
  134.                             OffsetPtr(dst, 1);
  135.                             dst^ := signedByte(mapbc[BAND(BOR(BSL(b1, 4), BAND(BSR(b2, 4), $0F)), $3F) + 1]);
  136.                             OffsetPtr(dst, 1);
  137.                             dst^ := signedByte(mapbc[BAND(BOR(BSL(b2, 2), BAND(BSR(b3, 6), $03)), $3F) + 1]);
  138.                             OffsetPtr(dst, 1);
  139.                             dst^ := signedByte(mapbc[BAND(b3, $3F) + 1]);
  140.                             OffsetPtr(dst, 1);
  141.                             newcount := newcount - 3;
  142.                             bh.linepos := bh.linepos + 4;
  143.                             count := count + 4;
  144.                         end;
  145.                         if newcount > 0 then begin
  146.                             b1 := src^;
  147.                             OffsetPtr(src, 1);
  148.                             dst^ := signedByte(mapbc[BAND(BSR(b1, 2), $3F) + 1]);
  149.                             OffsetPtr(dst, 1);
  150.                             bh.bits := b1;
  151.                             newcount := newcount - 1;
  152.                             bh.linepos := bh.linepos + 1;
  153.                             count := count + 1;
  154.                             bh.state := 2;
  155.                         end;
  156.                     end;
  157.                     2:  begin
  158.                         b2 := src^;
  159.                         OffsetPtr(src, 1);
  160.                         dst^ := signedByte(mapbc[BAND(BOR(BSL(bh.bits, 4), BAND(BSR(b2, 4), $0F)), $3F) + 1]);
  161.                         OffsetPtr(dst, 1);
  162.                         bh.bits := b2;
  163.                         newcount := newcount - 1;
  164.                         bh.linepos := bh.linepos + 1;
  165.                         count := count + 1;
  166.                         bh.state := 4;
  167.                     end;
  168.                     4:  begin
  169.                         b3 := src^;
  170.                         OffsetPtr(src, 1);
  171.                         dst^ := signedByte(mapbc[BAND(BOR(BSL(bh.bits, 2), BAND(BSR(b3, 6), $03)), $3F) + 1]);
  172.                         OffsetPtr(dst, 1);
  173.                         bh.linepos := bh.linepos + 2;
  174.                         if bh.linepos > 64 then begin
  175.                             dst^ := 13;
  176.                             OffsetPtr(dst, 1);
  177.                             count := count + 1;
  178.                             if bh.crlf then begin
  179.                                 dst^ := 10;
  180.                                 OffsetPtr(dst, 1);
  181.                                 count := count + 1;
  182.                             end;
  183.                             bh.linepos := 1;
  184.                         end;
  185.                         dst^ := signedByte(mapbc[BAND(b3, $3F) + 1]);
  186.                         OffsetPtr(dst, 1);
  187.                         newcount := newcount - 1;
  188.                         count := count + 2;
  189.                         bh.state := 0;
  190.                     end;
  191.                 end;
  192.             end;
  193.         end;
  194.         if eofile then begin
  195.             case bh.state of
  196.                 0:  begin
  197.                 end;
  198.                 2:  begin
  199.                     dst^ := signedByte(mapbc[BAND(BSL(bh.bits, 4), $3F) + 1]);
  200.                     OffsetPtr(dst, 1);
  201.                     count := count + 1;
  202.                 end;
  203.                 4:  begin
  204.                     dst^ := signedByte(mapbc[BAND(BSL(bh.bits, 2), $3F) + 1]);
  205.                     OffsetPtr(dst, 1);
  206.                     count := count + 1;
  207.                 end;
  208.             end;
  209.             dst^ := ord(':');
  210.             OffsetPtr(dst, 1);
  211.             dst^ := 13;
  212.             OffsetPtr(dst, 1);
  213.             count := count + 2;
  214.             if bh.crlf then begin
  215.                 dst^ := 10;
  216.                 OffsetPtr(dst, 1);
  217.                 count := count + 1;
  218.             end;
  219.         end;
  220.     end;
  221.  
  222.     procedure BHGetByte (var bh: BinHexEncodeState; p: ptr; len: longint; var count: longint; var err: OSErr; var n: integer);
  223.         procedure GB (var n: integer);
  224.             label
  225.                 1;
  226.             var
  227.                 b: integer;
  228.         begin
  229.             if err = noErr then begin
  230. 1:
  231.                 while (count < len) & (AddPtrLong(p, count)^ < 32) do begin
  232.                     count := count + 1;
  233.                 end;
  234.                 if count >= len then begin
  235.                     err := notEnoughData;
  236.                 end
  237.                 else begin
  238.                     b := map[BAND(AddPtrLong(p, count)^, $FF)];
  239.                     count := count + 1;
  240.                     if b = dud_byte then begin
  241.                         err := -3;
  242.                     end
  243.                     else begin
  244.                         case bh.state of
  245.                             0:  begin
  246.                                 bh.bits := b;
  247.                                 bh.state := 1;
  248.                                 goto 1;
  249.                             end;
  250.                             1:  begin
  251.                                 n := BOR(BSL(bh.bits, 2), BAND(BSR(b, 4), $03));
  252.                                 bh.bits := b;
  253.                                 bh.state := 2;
  254.                             end;
  255.                             2:  begin
  256.                                 n := BOR(BSL(bh.bits, 4), BAND(BSR(b, 2), $0F));
  257.                                 bh.bits := b;
  258.                                 bh.state := 3;
  259.                             end;
  260.                             3:  begin
  261.                                 n := BOR(BSL(bh.bits, 6), BAND(b, $3F));
  262.                                 bh.state := 0;
  263.                             end;
  264.                         end;
  265.                         n := BAND(n, $FF);
  266.                     end;
  267.                 end;
  268.             end;
  269.         end;
  270.  
  271.         label
  272.             1;
  273.         var
  274.             c: integer;
  275.             oldstate: BinHexEncodeState;
  276.             oldcount: longint;
  277.     begin
  278. 1:
  279.         if err = noErr then begin
  280.             oldstate := bh;
  281.             oldcount := count;
  282.             if bh.repcnt > 0 then begin
  283.                 n := bh.lastbyte;
  284.                 bh.repcnt := bh.repcnt - 1;
  285.             end
  286.             else begin
  287.                 GB(n);
  288.                 if (err = noErr) & (n = rep) then begin
  289.                     GB(c);
  290.                     if err = noErr then begin
  291.                         case c of
  292.                             0: 
  293.                                 ; { Do nothing, pass back the literal rep }
  294.                             1: 
  295.                                 goto 1; { Pretty damn stupid to have a rep count of 1 }
  296.                             otherwise begin
  297.                                 n := bh.lastbyte;
  298.                                 bh.repcnt := c - 2;
  299.                             end;
  300.                         end;
  301.                     end;
  302.                 end;
  303.             end;
  304.             if err = notEnoughData then begin
  305.                 bh := oldstate;
  306.                 count := oldcount;
  307.             end
  308.             else begin
  309.                 CalcMBCRC(bh.crc, n);
  310.                 bh.lastbyte := n;
  311.             end;
  312.         end;
  313.     end;
  314.  
  315.     function BinHexDecodeStart (var bh: BinHexEncodeState; var name: str63; var fi: FInfo; var dlen, rlen: longint; p: ptr; len: longint; var count: longint): OSErr;
  316.         var
  317.             err: OSErr;
  318.  
  319.         procedure GetByte (var n: integer);
  320.         begin
  321.             BHGetByte(bh, p, len, count, err, n);
  322.         end;
  323.  
  324.         procedure GetInteger (var x: univ integer);
  325.             var
  326.                 n, i: integer;
  327.         begin
  328.             x := 0;
  329.             for i := 1 to 2 do begin
  330.                 GetByte(n);
  331.                 x := BOR(BSL(x, 8), n);
  332.             end;
  333.         end;
  334.  
  335.         procedure GetLong (var x: univ longint);
  336.             var
  337.                 n, i: integer;
  338.         begin
  339.             x := 0;
  340.             for i := 1 to 4 do begin
  341.                 GetByte(n);
  342.                 x := BOR(BSL(x, 8), n);
  343.             end;
  344.         end;
  345.  
  346.         var
  347.             namelen, n, i: integer;
  348.             thecrc, realcrc: integer;
  349.     begin
  350.         err := notEnoughData;
  351.         count := 0;
  352.         while count < len - binhex_check_length do begin
  353.             if AddPtrLong(p, count)^ = first_binhex_char then begin
  354.                 if AddPtrLong(p, count + 1)^ = second_binhex_char then begin
  355.                     i := 3;
  356.                     while (i <= binhex_check_length) and (AddPtrLong(p, count + i - 1)^ = ord(binhex_start_string[i])) do begin
  357.                         i := i + 1;
  358.                     end;
  359.                     if i > binhex_check_length then begin
  360.                         err := noErr;
  361.                         leave;
  362.                     end;
  363.                 end;
  364.             end;
  365.             count := count + 1;
  366.         end;
  367.         if err = noErr then begin
  368.             count := count + binhex_check_length;
  369.             while (count < len) & (AddPtrLong(p, count)^ >= 32) do begin
  370.                 count := count + 1;
  371.             end;
  372.             while (count < len) & (AddPtrLong(p, count)^ <= 32) do begin
  373.                 count := count + 1;
  374.             end;
  375.             if count >= len then begin
  376.                 err := notEnoughData;
  377.             end
  378.             else if (AddPtrLong(p, count)^ <> ord(':')) then begin
  379.                 err := -7;
  380.             end
  381.             else begin
  382.                 count := count + 1;
  383.             end;
  384.         end;
  385.         if err = noErr then begin
  386.             bh.state := 0;
  387.             bh.repcnt := 0;
  388.             bh.crc := 0;
  389.             GetByte(namelen);
  390.             if (err = noErr) & ((namelen <= 0) | (namelen > 63)) then begin
  391.                 err := -4;
  392.             end;
  393.         end;
  394.         if (err = noErr) then begin
  395.             name[0] := chr(namelen);
  396.             if (err = noErr) then begin
  397.                 for i := 1 to namelen do begin
  398.                     GetByte(n);
  399.                     name[i] := chr(n);
  400.                 end;
  401.             end;
  402.             GetByte(n);
  403.             if (err = noErr) & (n <> 0) then begin
  404.                 err := -5;
  405.             end;
  406.             GetLong(fi.fdType);
  407.             GetLong(fi.fdCreator);
  408.             GetInteger(fi.fdFlags);
  409.             GetLong(dlen);
  410.             bh.dlen := dlen;
  411.             GetLong(rlen);
  412.             bh.rlen := rlen;
  413.             realcrc := bh.crc;
  414.             GetInteger(thecrc);
  415.             bh.crc := 0;
  416.             bh.datafork := true;
  417.             if (err = noErr) & ((dlen < 0) | (dlen > $10000000) | (rlen < 0) | (rlen > $10000000) | (thecrc <> realcrc)) then begin
  418.                 err := -6;
  419.             end;
  420.         end;
  421.         BinHexDecodeStart := err;
  422.     end;
  423.  
  424.     function BinHexDecodeChunk (var bh: BinHexEncodeState; inp: ptr; inlen: longint; var inused: longint; outp: ptr; outlen: longint; var outused: longint; var eofork, eofile: boolean): OSErr;
  425.         var
  426.             err: OSErr;
  427.             n, h, l: integer;
  428.             oldinused: longint;
  429.             oldstate: BinHexEncodeState;
  430.             realcrc, thecrc: integer;
  431.     begin
  432.         err := noErr;
  433.         inused := 0;
  434.         outused := 0;
  435.         eofork := false;
  436.         eofile := false;
  437.         while (err = noErr) & (bh.dlen > 0) & (outused < outlen) do begin
  438.             BHGetByte(bh, inp, inlen, inused, err, n);
  439.             if err = noErr then begin
  440.                 bh.dlen := bh.dlen - 1;
  441.                 AddPtrLong(outp, outused)^ := n;
  442.                 outused := outused + 1;
  443.             end;
  444.         end;
  445.         if (err = noErr) & (bh.dlen = 0) then begin
  446.             oldstate := bh;
  447.             oldinused := inused;
  448.             realcrc := bh.crc;
  449.             BHGetByte(bh, inp, inlen, inused, err, h);
  450.             BHGetByte(bh, inp, inlen, inused, err, l);
  451.             if err = noErr then begin
  452.                 thecrc := BOR(BSL(h, 8), l);
  453.                 if thecrc <> realcrc then begin
  454.                     err := -8;
  455.                 end
  456.                 else begin
  457.                     eofork := true;
  458.                     eofile := not bh.datafork;
  459.                     bh.datafork := false;
  460.                     bh.dlen := bh.rlen;
  461.                 end;
  462.             end
  463.             else if err = notEnoughData then begin
  464.                 err := noErr;
  465.                 bh := oldstate;
  466.                 inused := oldinused;
  467.             end;
  468.         end;
  469.         if err = notEnoughData then begin
  470.             err := noErr;
  471.         end;
  472.         BinHexDecodeChunk := err;
  473.     end;
  474.  
  475.     procedure StartupBinHex;
  476.         var
  477.             i: integer;
  478.     begin
  479.         for i := 0 to 255 do begin
  480.             map[i] := dud_byte;
  481.         end;
  482.         for i := 1 to length(mapbc) do begin
  483.             map[ord(mapbc[i])] := i - 1;
  484.         end;
  485.         StartupCalcCRC;
  486.     end;
  487.  
  488. end.